Unit Msc; { *************************************************************************************** Utility toutines called by AE.p but do not have AppleEvent-specific code inthem. *************************************************************************************** } interface uses Memory, QuickDraw, Packages, Menus, Events, Fonts, Scrap, ToolUtils,Resources, Errors, Palettes, LowMem, Errors, Math,Background,Analysis,Stacks, globals, Utilities, Edit, Filters, Graphics, Camera, PlugIns, Macros1, Macros2, File1, File2, Lut, Text, Sound; function FindMenuItem(inMenu:MenuHandle; firstItem:integer; var inString: str255): integer; procedure SetImportOptions(inString: str255); procedure SetExportOptions(inString: str255); procedure SetScalingMode(ScalingOptions: str255); procedure SetTextStyle(Attributes:str255); procedure RunNamedFilter(fType: str255); procedure RunNamedConvolution(fType: str255); procedure SetMathOp(op:str255); procedure DoSetOptions(Options:string); procedure CheckIndex(var index: LongInt;min, max: LongInt); procedure PlayBeep(inName:str255); procedure BinaryCommand(inCommand:integer; inCount:integer); procedure ShadowCommand(inFilter:integer); procedure FilterCommand(inFilter:integer); function OpenFileFSSpec(myFSS:FSSpec):OSErr; function OpenAFile(fname: str255; VRefNum: integer):OSErr; procedure SetSaveAs(theMode:DescType); procedure PleaseWait(seconds: extended); procedure ApplyPasteMath(theEnum:DescType); function GetAString(prompt,default:str255): str255; implementation procedure DrawROI; forward; procedure CheckIndex(var index: LongInt;min, max: LongInt); begin if index < 0 then index := max - index; { handle Last and reverse } if index< min then index := min else if index > max then index := max; end; procedure PlayBeep(inName:str255); var ignoreErr:OSErr; myChan:SndChannelPtr; sh:SndListHandle; begin myChan := nil; sh := SndListHandle(GetNamedResource('snd ',inName)); if sh = nil then Beep else begin HLock(Handle(sh)); ignoreErr := SndPlay(myChan, sh, false); HUnlock(Handle(sh)); ReleaseResource(Handle(sh)); end end; procedure BinaryCommand(inCommand:integer; inCount:integer); var t: FateTable; {Only needed for MakeSkeleton} oldCount:integer; begin if inCommand = 9 then begin if (inCount >= 1) and (inCount <= 8) then begin BinaryCount := inCount; BinaryThreshold := BinaryCount * 255; end; exit(BinaryCommand); end; oldCount := BinaryIterations; if (inCount >= 1) and (inCount < 100) then BinaryIterations := inCount; case inCommand of 1: MakeBinary; 2: DoErosion; 3: DoDilation; 4: DoOpening; 5: DoClosing; 6: filter(OutlineFilter, 0, t); 7: MakeSkeleton; 8: oldCount := inCount;{ SetIterations; } { 9: SetBinaryCount; } end; BinaryIterations := oldCount; end; procedure FilterCommand(inFilter:integer); var t:FateTable; begin case inFilter of 1: Filter(WeightedAvg, 0, t); 2: Filter(UnweightedAvg, 0, t); 3: Filter(fsharpen, 0, t); 4: Filter(SharpenMore, 0, t); 5: Filter(FindEdges, 0, t); 6: Filter(FindEdges, 0, t); { sobel } 7: Filter(EdgeDetect, 0, t); {Skeletonize} 8: Filter(ReduceNoise, 0, t); 9: Filter(Dither, 0, t); 10: begin RankFilter := MedianRank; DoRankFilter; end; 11: begin RankFilter := MinRank; DoRankFilter; end; 12: begin RankFilter := MaxRank; DoRankFilter; end; end; end; procedure ShadowCommand(inFilter:integer); var t:FateTable; begin case inFilter of 1: Filter(ShadowN, 0, t); 2: Filter(ShadowNE, 0, t); 3: Filter(ShadowE, 0, t); 4: Filter(ShadowSE, 0, t); 5: Filter(ShadowS, 0, t); 6: Filter(ShadowSW, 0, t); 7: Filter(ShadowW, 0, t); 8: Filter(ShadowNW, 0, t); end; end; function OpenFileFSSpec(myFSS:FSSpec):OSErr; var theInfo: FInfo; err, err1, err2:OSErr; wdRefNum:integer; okay:boolean; begin OpenFileFSSpec:=fnfErr; with myFSS do begin err := OpenWD(VRefNum, parID, 0, wdRefNum); if err<>noErr then exit(OpenFileFSSpec); err := GetFInfo(name, wdRefNum, theInfo); if err<>noErr then exit(OpenFileFSSpec); if theInfo.fdType = 'TIFF' then begin WhatToOpen := OpenTIFF; okay := OpenFile(name, wdRefNum); if OpeningRGB then begin if okay then ConvertRGBToEightBitColor(true); OpeningRGB := false; end; end; if theInfo.fdType = 'PICT' then begin okay := OpenPICT(name, wdRefNum, false); end; if theInfo.fdType = 'TEXT' then begin okay := OpenTextFile(name, wdRefNum); end; if theInfo.fdType = 'PICS' then begin okay := OpenPICS(name, wdRefNum); end; if theInfo.fdType = 'Iout' then begin OpenOutline(name, wdRefNum); okay:=true; end; if theInfo.fdType = 'ICOL' then begin OpenColorTable(name, wdRefNum); okay:=true; end; if theInfo.fdType = 'IPIC' then begin WhatToOpen := OpenImage; okay := OpenFile(name, wdRefNum); end; if okay then OpenFileFSSpec := noErr else OpenFileFSSpec := errAEEventNotHandled; end; end; function OpenAFile(name: str255; wdRefNum: integer):OSErr; var theInfo: FInfo; err, err1, err2:OSErr; okay:boolean; begin OpenAFile:=fnfErr; err := GetFInfo(name, wdRefNum, theInfo); if err<>noErr then exit(OpenAFile); if theInfo.fdType = 'TIFF' then begin WhatToOpen := OpenTIFF; okay := OpenFile(name, wdRefNum); if OpeningRGB then begin if okay then ConvertRGBToEightBitColor(true); OpeningRGB := false; end; end; if theInfo.fdType = 'PICT' then begin okay := OpenPICT(name, wdRefNum, false); end; if theInfo.fdType = 'TEXT' then begin okay := OpenTextFile(name, wdRefNum); end; if theInfo.fdType = 'PICS' then begin okay := OpenPICS(name, wdRefNum); end; if theInfo.fdType = 'Iout' then begin OpenOutline(name, wdRefNum); okay:=true; end; if theInfo.fdType = 'ICOL' then begin OpenColorTable(name, wdRefNum); okay:=true; end; if theInfo.fdType = 'IPIC' then begin WhatToOpen := OpenImage; okay := OpenFile(name, wdRefNum); end; if okay then OpenAFile := noErr else OpenAFile := errAEEventNotHandled; end; procedure SetExportOptions(Attributes: str255); begin MakeLowerCase(Attributes); ExportAsWhat := AsRaw; if pos('mcid', Attributes) <> 0 then ExportAsWhat := asMCID; if pos('text', Attributes) <> 0 then ExportAsWhat := asText; if pos('lut', Attributes) <> 0 then ExportAsWhat := asLUT; if pos('meas', Attributes) <> 0 then ExportAsWhat := asMeasurements; if pos('plot', Attributes) <> 0 then ExportAsWhat := asPlotValues; if pos('hist', Attributes) <> 0 then ExportAsWhat := asHistogramValues; if pos('xy', Attributes) <> 0 then ExportAsWhat := asCoordinates; end; procedure SetSaveAs(theMode:DescType); begin if info^.StackInfo <> nil then SaveAsWhat:= asPICS else SaveAsWhat:= asTIFF; if theMode = 'TIFF' then SaveAsWhat:= asTIFF else if theMode = 'PICT' then SaveAsWhat:= asPICT else if theMode = 'MacP' then SaveAsWhat:= asMacPaint else if theMode = 'PICS' then SaveAsWhat:= asPICS else if theMode = 'LUT ' then SaveAsWhat:= AsPalette else if theMode = 'OutL' then SaveAsWhat:= AsOutline end; procedure SetImportOptions(Attributes: str255); begin MakeLowerCase(Attributes); WhatToImport := ImportTIFF; ImportCustomDepth := EightBits; ImportSwapBytes := false; ImportCalibrate := false; ImportAll := false; ImportAutoScale := true; ImportInvert := false; if pos('dicom', Attributes) <> 0 then WhatToImport := ImportDICOM; if pos('mcid', Attributes) <> 0 then WhatToImport := ImportMCID; if pos('look', Attributes) <> 0 then WhatToImport := ImportLUT; if pos('palette', Attributes) <> 0 then WhatToImport := ImportLUT; if pos('text', Attributes) <> 0 then WhatToImport := ImportText; if pos('custom', Attributes) <> 0 then WhatToImport := ImportCustom; if (pos('8', Attributes) <> 0) or (pos('eight', Attributes) <> 0) then begin ImportCustomDepth := EightBits; WhatToImport := ImportCustom; end; if (pos('signed', Attributes) <> 0) then begin ImportCustomDepth := SixteenBitsSigned; WhatToImport := ImportCustom; end; if (pos('unsigned', Attributes) <> 0) then begin ImportCustomDepth := SixteenBitsUnsigned; WhatToImport := ImportCustom; end; if (pos('swap', Attributes) <> 0) then ImportSwapBytes := true; if (pos('calibrate', Attributes) <> 0) then ImportCalibrate := true; if (pos('fixed', Attributes) <> 0) then ImportAutoScale := false; if (pos('all', Attributes) <> 0) then ImportAll := true; if (pos('invert', Attributes) <> 0) then ImportInvert := true; end; procedure SetScalingMode(ScalingOptions: str255); begin MakeLowerCase(ScalingOptions); rsInteractive := false; if pos('bilinear', ScalingOptions) <> 0 then rsMethod := Bilinear; if pos('nearest', ScalingOptions) <> 0 then rsMethod := NearestNeighbor; if pos('new', ScalingOptions) <> 0 then rsCreateNewWindow := true; if pos('same', ScalingOptions) <> 0 then rsCreateNewWindow := false; if pos('interactive', ScalingOptions) <> 0 then rsInteractive := true; end; procedure SetTextStyle(Attributes:str255); begin MakeLowerCase(Attributes); if pos('with', Attributes) <> 0 then TextBack := WithBack; if pos('no', Attributes) <> 0 then TextBack := NoBack; if pos('left', Attributes) <> 0 then TextJust := teJustLeft; if pos('center', Attributes) <> 0 then TextJust := teJustCenter; if pos('right', Attributes) <> 0 then TextJust := teJustRight; CurrentStyle := []; if pos('bold', Attributes) <> 0 then CurrentStyle := CurrentStyle + [Bold]; if pos('italic', Attributes) <> 0 then CurrentStyle := CurrentStyle + [Italic]; if pos('underline', Attributes) <> 0 then CurrentStyle := CurrentStyle + [Underline]; if pos('outline', Attributes) <> 0 then CurrentStyle := CurrentStyle + [Outline]; if pos('shadow', Attributes) <> 0 then CurrentStyle := CurrentStyle + [Shadow]; end; function FindMenuItem(inMenu:MenuHandle; firstItem:integer; var inString: str255):integer; var i,n:integer; theItem:str255; begin MakeLowerCase(inString); n := CountMItems(inMenu); for i := firstItem to n do begin GetMenuItemText(inMenu,i,theItem); MakeLowerCase(theItem); if pos(inString, theItem) <> 0 then begin FindMenuItem := i - firstItem + 1; exit(FindMenuItem); end; end; FindMenuItem := 0; end; function GetAString(prompt,default:str255): str255; const StringID = 3; var mylog: DialogPtr; item: integer; begin if ForceToFront <> noErr then begin GetAString := 'cancel'; exit(GetAString); { AE - RMD 1/10/95 } end; InitCursor; ParamText(prompt, '', '', ''); mylog := GetNewDialog(170, nil, pointer(-1)); SetDString(MyLog, StringID, default); SelectdialogItemText(MyLog, StringID, 0, 32767); OutlineButton(MyLog, ok, 16); repeat ModalDialog(nil, item); until (item = ok) or (item = cancel); if item = ok then GetAString := GetDString(MyLog, StringID) else GetAString := default; DisposeDialog(mylog); end; procedure RunNamedFilter(fType: str255); var doMore:boolean; t:FateTable; begin MakeLowerCase(fType); doMore:=pos('more', fType) <> 0; if pos('smooth', fType) <> 0 then begin if doMore then Filter(UnweightedAvg, 0, t) else Filter(WeightedAvg, 0, t); exit(RunNamedFilter); end; if pos('sharpen', fType) <> 0 then begin if doMore then Filter(SharpenMore, 0, t) else Filter(fsharpen, 0, t); exit(RunNamedFilter); end; if pos('median', fType) <> 0 then begin RankFilter := MedianRank; DoRankFilter; exit(RunNamedFilter); end; if (pos('edges', fType) <> 0) or (pos('sobel', fType)<>0) then begin Filter(FindEdges, 0, t); exit(RunNamedFilter); end; if pos('dither', fType) <> 0 then begin Filter(Dither, 0, t); exit(RunNamedFilter); end; if pos('min', fType) <> 0 then begin RankFilter := MinRank; DoRankFilter; exit(RunNamedFilter); end; if pos('max', fType) <> 0 then begin RankFilter := MaxRank; DoRankFilter; exit(RunNamedFilter); end; if fType='ReduceNoise' then Filter(ReduceNoise, 0, t) else if fType='Dither' then Filter(Dither, 0, t) else if fType='EdgeDetect' then Filter(EdgeDetect, 0, t) else if fType='Skeletonize' then Filter(EdgeDetect, 0, t) else if fType='Outline' then Filter(OutlineFilter, 0, t) else if fType='ne' then Filter(ShadowNE, 0, t) else if fType='e' then Filter(ShadowE, 0, t) else if fType='se' then Filter(ShadowSE, 0, t) else if fType='s' then Filter(ShadowS, 0, t) else if fType='sw' then Filter(ShadowSW, 0, t) else if fType='w' then Filter(ShadowW, 0, t) else if fType='nw' then Filter(ShadowNW, 0, t) end; procedure RunNamedConvolution(fname: str255); var err: OSErr; f: integer; FileFound: boolean; begin if (fname = '') and (CurrentWindow = TextKind) then begin ConvolveUsingText; exit(RunNamedConvolution); end; err := fsopen(fname, KernelsRefNum, f); FileFound := err = NoErr; err := fsclose(f); if FileFound then convolve(fname, KernelsRefNum) else convolve('', 0); end; procedure SetMathOp(op:str255); var roi:rect; DstInfo:InfoPtr; begin MakeLowerCase(op); CalibrateImageMath:=false; if pos('calibrate', op) <> 0 then CalibrateImageMath := true; if pos('add', op) <> 0 then CurrentMathOp := AddMath; if pos('sub', op) <> 0 then CurrentMathOp := SubMath; if pos('mul', op) <> 0 then CurrentMathOp := MulMath; if pos('div', op) <> 0 then CurrentMathOp := DivMath; if pos('and', op) <> 0 then CurrentMathOp := AndMath; if pos('or', op) <> 0 then CurrentMathOp := OrMath; if pos('xor', op) <> 0 then CurrentMathOp := XorMath; if pos('max', op) <> 0 then CurrentMathOp := MaxMath; if pos('min', op) <> 0 then CurrentMathOp := MinMath; if pos('copy', op) <> 0 then CurrentMathOp := CopyMath; { MathGain := gain; MathOffset := offset; if not GetMathRoi(pic1, pic2, roi) then exit(RunImageMath); if nwindow = '' then begin DstInfo := GetInfoPtr(DstPidNum); if DstInfo=nil then exit(RunImageMath); SelectWindow(DstInfo^.wptr); Info := DstInfo; ActivateWindow; LoadLUT(info^.cTable); UpdatePicWindow; KillRoi; end else begin with roi do if not NewPicWindow(nwindow, right-left, bottom-top) then exit(RunImageMath); DstInfo := Info; end; DoMath(pic1, pic2, DstInfo, roi); } end; procedure DoSetOptions(Options:string); var mtype: MeasurementTypes; i, LastOption: integer; SaveMeasurements: SetOfMeasurements; begin SaveMeasurements := measurements; MakeLowerCase(options); Measurements := []; if pos('area', options) <> 0 then Measurements := Measurements + [AreaM]; if pos('mean', options) <> 0 then Measurements := Measurements + [MeanM]; if pos('st', options) <> 0 then Measurements := Measurements + [StdDevM]; if pos('center', options) <> 0 then Measurements := Measurements + [xyLocM]; if pos('mode', options) <> 0 then Measurements := Measurements + [ModeM]; if (pos('per', options) <> 0) or (pos('length', options) <> 0) then Measurements := Measurements + [LengthM]; if pos('major', options) <> 0 then Measurements := Measurements + [MajorAxisM]; if pos('minor', options) <> 0 then Measurements := Measurements + [MinorAxisM]; if pos('angle', options) <> 0 then Measurements := Measurements + [AngleM]; if pos('int', options) <> 0 then Measurements := Measurements + [IntDenM]; if pos('max', options) <> 0 then Measurements := Measurements + [MinMaxM]; if pos('1', options) <> 0 then Measurements := Measurements + [User1M]; if pos('2', options) <> 0 then Measurements := Measurements + [User2M]; UpdateFitEllipse; if Measurements <> SaveMeasurements then UpdateList; end; procedure PleaseWait(seconds: extended); var SaveTicks: LongInt; theEvent: EventRecord; key:Boolean; begin SaveTicks := TickCount + round(seconds * 60.0); repeat if Digitizing then begin CaptureAndDisplayFrame; if ContinuousHistogram then ShowContinuousHistogram; key := WaitNextEvent( 0, theEvent, 0, nil ); end else key := WaitNextEvent( 0, theEvent, 2, nil ); if info^.RoiShowing and (RoiUpdateTime < 30) then DrawRoi; ; {Allows background tasks to run} until (TickCount > SaveTicks) or CommandPeriod; end; procedure GetLineHandles (var LeftHandle, MiddleHandle, RightHandle: rect); var offset1, offset2, xcenter, ycenter, x1, y1, x2, y2: integer; rx1, ry1, rx2, ry2: extended; begin offset1 := RoiHandleSize div 2; offset2 := offset1 + 1; GetLoi(rx1, ry1, rx2, ry2); x1 := trunc(rx1); y1 := trunc(ry1); x2 := trunc(rx2); y2 := trunc(ry2); SetRect(LeftHandle, x1 - offset1, y1 - offset1, x1 + offset2, y1 + offset2); with info^.RoiRect do begin xcenter := left + (right - left) div 2; ycenter := top + (bottom - top) div 2; end; SetRect(MiddleHandle, xcenter - offset1, ycenter - offset1, xcenter + offset2, ycenter + offset2); SetRect(RightHandle, x2 - offset1, y2 - offset1, x2 + offset2, y2 + offset2); end; procedure UndoRoi; var SrcPtr, DstPtr: ptr; offset, ByteCount, tTop, tBottom: LongInt; tRect: rect; begin with info^ do begin if PixMapSize <> CurrentUndoSize then exit(UndoRoi); tRect := RoiRect; if RoiType = LineRoi then InsetRect(tRect, -RoiHandleSize, -RoiHandleSize); with tRect do begin tTop := top; tBottom := bottom; if tTop < 0 then tTop := 0; if tTop > PicRect.bottom then tTop := PicRect.bottom; if tBottom < 0 then tBottom := 0; if tBottom > PicRect.bottom then tBottom := PicRect.bottom; end; offset := tTop * BytesPerRow; if offset < 0 then offset := 0; SrcPtr := ptr(ord4(UndoBuf) + offset); DstPtr := ptr(ord4(PicBaseAddr) + offset); ByteCount := (tBottom - tTop) * BytesPerRow; BlockMove(SrcPtr, DstPtr, ByteCount); end; end; procedure DrawROI; var tRect: rect; RoiHandle, LeftHandle, MiddleHandle, RightHandle: rect; psize: integer; StartTicks: LongInt; SaveGDevice: GDHandle; begin with Info^ do begin StartTicks := TickCount; if OpPending then DoOperation(CurrentOp); SaveGDevice := GetGDevice; SetGDevice(osGDevice); SetPort(GrafPtr(Info^.osPort)); PenNormal; if ScaleToFitWindow then if (magnification < 1.0) and (magnification <> 0.0) then begin psize := round(1.0 / magnification + 1.5); PenSize(psize, psize); end; if not ((MouseState = DownInRoi) and OpPending) then if PixMapSize <= UndoBufSize then begin pmForeColor(BlackIndex); pmBackColor(WhiteIndex); case RoiType of RectRoi: with RoiRect do begin SetRect(RoiHandle, right - RoiHandleSize, bottom - RoiHandleSize, right, bottom); if ((right - left) > RoiHandleSize) and ((bottom - top) > RoiHandleSize) then PaintRect(RoiHandle); end; LineRoi: if Magnification <= 2.0 then begin GetLineHandles(LeftHandle, MiddleHandle, RightHandle); PaintRect(LeftHandle); if LineWidth < 4 then PaintRect(MiddleHandle); PaintRect(RightHandle); pmForeColor(WhiteIndex); FrameRect(LeftHandle); if LineWidth < 4 then FrameRect(MiddleHandle); FrameRect(RightHandle); pmForeColor(BlackIndex); end; otherwise end; PatIndex := (PatIndex + 1) mod 8; PenPat(AntPattern[PatIndex]); FrameRgn(roiRgn); pmForeColor(ForegroundIndex); pmBackColor(BackgroundIndex); end; if PixMapSize > UndoBufSize then begin if magnification < 1.0 then PenSize(2, 2); PatIndex := (PatIndex + 1) mod 8; PenPat(AntPattern[PatIndex]); PenMode(PatXor); FrameRgn(roiRgn); if MouseState = DownInRoi then begin UnionRect(RoiRect, OldRoiRect, tRect); UpdateScreen(tRect); end else UpdateScreen(RoiRect); FrameRgn(roiRgn); end else begin tRect := RoiRect; if MouseState = DownInRoi then UnionRect(RoiRect, OldRoiRect, tRect) else if RoiNudged then begin tRect := RoiRect; RoiNudged := false; end; if RoiType = LineRoi then InsetRect(tRect, -RoiHandleSize * 2, -RoiHandleSize * 2) else InsetRect(tRect, -2, -2); UpdateScreen(tRect); UndoRoi; {Erase offscreen ROI} end; RoiUpdateTime := TickCount - StartTicks; end; {with} SetGDevice(SaveGDevice); end; procedure ApplyPasteMath(theEnum:DescType); begin if not (OpPending and (CurrentOp = PasteOp)) then exit(ApplyPasteMath); if theEnum = 'mAdd' then begin CurrentOp := AddOp; DoPasteMath; end else if theEnum = 'mSub' then begin CurrentOp := SubtractOp; DoPasteMath; end else if theEnum = 'mMul' then begin CurrentOp := SubtractOp; DoPasteMath; end else if theEnum = 'mDiv' then begin CurrentOp := DivideOp; DoPasteMath; end else begin SetForegroundColor(BlackIndex); SetBackGroundColor(WhiteIndex); if theEnum = 'mCop' then SetPasteMode(CopyModeItem) else if theEnum = 'mAND' then SetPasteMode(AndItem) else if theEnum = 'mOR ' then SetPasteMode(OrItem) else if theEnum = 'mXOR' then SetPasteMode(XorItem) else if theEnum = 'mBnd' then SetPasteMode(BlendItem) else if theEnum = 'mRep' then SetPasteMode(ReplaceItem); end; if OptionKeyWasDown then begin if PasteControl <> nil then DrawPasteControl; end else KillRoi; end; end.